مترجم سایت

طراحي بازي با ويژوال بيسيک نيازمند درک پايه کار با توابع API و مفاهيم مربتط با گرافيک است. شما بايد با مفهوم رابط گرافيکي، دايرکتکس، اکتيوکس و فرمتهاي گرافيکي مربوط به تصاوير آشنا باشيد. چون اين يک سايت آموزشي است از توضيح بيشتر در مورد بازيها اجتناب مي شود. آرش حبيبي

حرکت پس زمينه
تکنيک در خلق بازي بسيار موثر است. براي نمونه فرض کنيد بخواهيد پس زمينه را به حرکت درآوريد. براي شروع اين برنامه ساده را دانلود کنيد.

انتخاب کاراکتر
يک تکنيک ساده ديگر که در بسياري بازيها استفاده مي شود انتخاب کاراکتر است. سورس کد انتخاب کاراکتر را از اين لينک دانلود کنيد.

بازي جورچين
سورس کد کامل بازي جورچين يا پازل را از همين لينک دانلود کنيد.

بازي مار و پله
سورس کد کامل بازي مار و پله را از همين لينک دانلود کنيد.

بازي منچ
بازي منچ تحت شبکه پروژه اي است که هميشه به دانشجويان درس شبکه ارائه کرده ام. براي محک توانائي خود در بيسيک اين پروژه را انجام دهيد. پيشنهاد مي شود کار با کنترلهاي شبکه در VB6 را در همين سايت دنبال کنيد. روي لينک دانلود بازي منچ کليک کنيد.

بازي پينگ پنگ
سورس کامل کد بازي پينگ پنگ در زير ارائه شده است. براي افزايش توانمندي خود در طراحي بازي از مجموعه کدهاي زير استفاده کنيد. نام کنترلها و تنظيم خصوصيات آنها در زير آمده است. سپس از کدهاي ارائه شده استفاده کنيد:

Form frmPong:
BackColor = &H00FFC0C0& (Light blue)
Caption = The Original Video Game - Pong!

Timer timGame:
Enabled = False
Interval = 25 (may need different values for different machines)

PictureBox picPaddle:
Appearance = Flat
AutoRedraw = True
AutoSize = True
Picture = paddle.bmp
ScaleMode = Pixel
Visible = False

CommandButton cmdPause:
Caption = &Pause
Enabled = 0 'False

CommandButton cmdExit:
Caption = E&xit

CommandButton cmdNew:
Caption = &New Game
Default = True

PictureBox picField:
BackColor = &H0080FFFF& (Light yellow)
BorderStyle = None
FontName = MS Sans Serif
FontSize = 24
ForeColor = &H000000FF& (Red)
ScaleMode = Pixel

PictureBox picBlank:
Appearance = Flat
AutoRedraw = True
BackColor = &H0080FFFF& (Light yellow)
.           BorderStyle = None
FillStyle = Solid
Visible = False

PictureBox picBall:
Appearance = Flat
AutoRedraw = True
AutoSize = True
BorderStyle = None
Picture = ball.bmp
ScaleMode = Pixel
Visible = False

Shape Shape1:
BackColor = &H00404040& (Black)
BackStyle = Opaque

Label lblScore2:
Alignment = Center
BackColor = &H00FFFFFF& (White)
BorderStyle = Fixed Single
Caption = 0
FontName = MS Sans Serif
FontBold = True
FontSize = 18

Label Label3:
BackColor = &H00FFC0C0& (Light blue)
Caption = Player 2
FontName = MS Sans Serif
FontSize = 13.5

Label lblScore1:
Alignment = Center
BackColor = &H00FFFFFF& (White)
BorderStyle = Fixed Single
Caption = 0
FontName = MS Sans Serif
FontBold = True
FontSize = 18

Label Label1:
BackColor = &H00FFC0C0& (Light blue)
Caption = Player 1
FontName = MS Sans Serif
FontSize = 13.5

Code:

General Declarations:

Option Explicit
'Sound file strings
Dim wavPaddleHit As String
Dim wavWall As String
Dim wavMissed As String
'A user-defined variable to position bitmaps
Private Type tBitMap
Left As Long
Top As Long
Right As Long
Bottom As Long
Width As Long
Height As Long
End Type
'Ball information
Dim bmpBall As tBitMap
Dim XStart As Long, YStart As Long
Dim XSpeed As Long, YSpeed As Long
Dim SpeedUnit As Long
Dim XDir As Long, YDir As Long
'Paddle information
Dim bmpPaddle1 As tBitMap, bmpPaddle2 As tBitMap
Dim YStartPaddle1 As Long, YStartPaddle2 As Long
Dim XPaddle1 As Long, XPaddle2 As Long
Dim PaddleIncrement As Long

Dim Score1 As Integer, Score2 As Integer
Dim Paused As Boolean
'Number of points to win
Const WIN = 10
'Number of bounces before speed increases
Const BOUNCE = 10
Dim NumBounce As Integer
'API Functions and constants
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function sndStopSound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszNull As String, ByVal uFlags As Long) As Long
Const SND_ASYNC = &H1         
Const SND_SYNC = &H0
Const SND_MEMORY = &H4
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10
' Windows API rectangle function
Private Declare Function IntersectRect Lib "user32" (lpDestRect As tBitMap, lpSrc1Rect As tBitMap, lpSrc2Rect As tBitMap) As Long

NoiseGet General Function:

Function NoiseGet(ByVal FileName) As String
'------------------------------------------------------------
' Load a sound file into a string variable.
' Taken from:
'   Mark Pruett
'   Black Art of Visual Basic Game Programming
'   The Waite Group, 1995
'------------------------------------------------------------
Dim buffer As String
Dim f As Integer
Dim SoundBuffer As String
On Error GoTo NoiseGet_Error
buffer = Space$(1024)
SoundBuffer = ""
f = FreeFile
Open FileName For Binary As f
Do While Not EOF(f)
Get #f, , buffer     ' Load in 1K chunks
SoundBuffer = SoundBuffer & buffer
Loop
Close f
NoiseGet = Trim$(SoundBuffer)
Exit Function
NoiseGet_Error:
SoundBuffer = ""
Exit Function
End Function

NoisePlay General Procedure:

Sub NoisePlay(SoundBuffer As String, ByVal PlayMode As Integer)
'------------------------------------------------------------
' Plays a sound previously loaded into memory with function
' NoiseGet().
' Taken from:
'   Mark Pruett
'   Black Art of Visual Basic Game Programming
'   The Waite Group, 1995
'------------------------------------------------------------
Dim retcode As Integer
If SoundBuffer = "" Then Exit Sub
' Stop any sound that may currently be playing.
retcode = sndStopSound(0, SND_ASYNC)
' PlayMode should be SND_SYNC or SND_ASYNC
retcode = sndPlaySound(ByVal SoundBuffer, PlayMode Or SND_MEMORY)
End Sub

Bitmap_Move General Procedure:

Private Sub Bitmap_Move(ABitMap As tBitMap, ByVal NewLeft As Integer, ByVal NewTop As Integer, SourcePicture As PictureBox)
' Move bitmap from one location to the next
' Modified from:
'   Mark Pruett
'   Black Art of Visual Basic Game Programming
'   The Waite Group, 1995
Dim RtnValue As Integer
'First erase at old location
RtnValue = BitBlt(picField.hDC, ABitMap.Left, ABitMap.Top, ABitMap.Width, ABitMap.Height, picBlank.hDC, 0, 0, SRCCOPY)
'Then, establish and redraw at new location
ABitMap.Left = NewLeft
ABitMap.Top = NewTop
RtnValue = BitBlt(picField.hDC, ABitMap.Left, ABitMap.Top, ABitMap.Width, ABitMap.Height, SourcePicture.hDC, 0, 0, SRCCOPY)
End Sub

ResetPaddles General Procedure:

Private Sub ResetPaddles()
'Reposition paddles
bmpPaddle1.Top = YStartPaddle1
bmpPaddle2.Top = YStartPaddle2
Call Bitmap_Move(bmpPaddle1, bmpPaddle1.Left, bmpPaddle1.Top, picPaddle)
Call Bitmap_Move(bmpPaddle2, bmpPaddle2.Left, bmpPaddle2.Top, picPaddle)
End Sub

Update_Score General Procedure:

Private Sub Update_Score(Player As Integer)
Dim Winner As Integer, RtnValue As Integer
Winner = 0
'Update scores and see if game over
timGame.Enabled = False
Call NoisePlay(wavMissed, SND_SYNC)
Select Case Player
Case 1
Score2 = Score2 + 1
lblScore2.Caption = Format(Score2, "#0")
lblScore2.Refresh
If Score2 = WIN Then Winner = 2
Case 2
Score1 = Score1 + 1
lblScore1.Caption = Format(Score1, "#0")
lblScore1.Refresh
If Score1 = WIN Then Winner = 1
End Select
If Winner = 0 Then
Call ResetBall
timGame.Enabled = True
Else
cmdNew.Enabled = False
cmdPause.Enabled = False
cmdExit.Enabled = False
RtnValue = sndPlaySound(App.Path + "\cheering.wav", SND_SYNC)
picField.CurrentX = 0.5 * (picField.ScaleWidth - picField.TextWidth("Game Over"))
picField.CurrentY = 0.5 * picField.ScaleHeight - picField.TextHeight("Game Over")
picField.Print "Game Over"
cmdNew.Enabled = True
cmdExit.Enabled = True
End If
End Sub
ResetBall General Procedure:

Sub ResetBall()
'Set random directions
XDir = 2 * Int(2 * Rnd) - 1
YDir = 2 * Int(2 * Rnd) - 1
bmpBall.Left = XStart
bmpBall.Top = YStart
End Sub

cmdExit_Click Event:

Private Sub cmdExit_Click()
'End game
End
End Sub

cmdNew Click Event:

Private Sub cmdNew_Click()
'New game code
'Reset scores
lblScore1.Caption = "0"
lblScore2.Caption = "0"
Score1 = 0
Score2 = 0
'Reset ball
SpeedUnit = 1
XSpeed = 5 * SpeedUnit
YSpeed = XSpeed
Call ResetBall
'Reset paddles
picField.Cls
PaddleIncrement = 5
NumBounce = 0
Call ResetPaddles
cmdPause.Enabled = True
timGame.Enabled = True
picField.SetFocus
End Sub

Collided General Function:

Private Function Collided(A As tBitMap, B As tBitMap) As Integer
'--------------------------------------------------
' Check if the two rectangles (bitmaps) intersect,
' using the IntersectRect API call.
' Taken from:
'   Mark Pruett
'   Black Art of Visual Basic Game Programming
'   The Waite Group, 1995
'--------------------------------------------------

' Although we won't use it, we need a result
' rectangle to pass to the API routine.
Dim ResultRect As tBitMap

    ' Calculate the right and bottoms of rectangles needed by the API call.
A.Right = A.Left + A.Width - 1
A.Bottom = A.Top + A.Height - 1

    B.Right = B.Left + B.Width - 1
B.Bottom = B.Top + B.Height - 1

    ' IntersectRect will only return 0 (false) if the
' two rectangles do NOT intersect.
Collided = IntersectRect(ResultRect, A, B)
End Function

cmdPause Click Event:

Private Sub cmdPause_Click()
If Not (Paused) Then
timGame.Enabled = False
cmdNew.Enabled = False
Paused = True
cmdPause.Caption = "&UnPause"
Else
timGame.Enabled = True
cmdNew.Enabled = True
Paused = False
cmdPause.Caption = "&Pause"
End If
picField.SetFocus
End Sub

Form Load Event:

Private Sub Form_Load()
Randomize Timer
'Place from at middle of screen
frmPong.Left = 0.5 * (Screen.Width - frmPong.Width)
frmPong.Top = 0.5 * (Screen.Height - frmPong.Height)
'Load sound files into strings from fast access
wavPaddleHit = NoiseGet(App.Path + "\paddle.wav")
wavMissed = NoiseGet(App.Path + "\missed.wav")
wavWall = NoiseGet(App.Path + "\wallhit.wav")
'Initialize ball and paddle locations
XStart = 0.5 * (picField.ScaleWidth - picBall.ScaleWidth)
YStart = 0.5 * (picField.ScaleHeight - picBall.ScaleHeight)
XPaddle1 = 5
XPaddle2 = picField.ScaleWidth - picPaddle.ScaleWidth - 5
YStartPaddle1 = 0.5 * (picField.ScaleHeight - picPaddle.ScaleHeight)
YStartPaddle2 = YStartPaddle1
'Get ball dimensions
bmpBall.Left = XStart
bmpBall.Top = YStart
bmpBall.Width = picBall.ScaleWidth
bmpBall.Height = picBall.ScaleHeight
'Get paddle dimensions
bmpPaddle1.Left = XPaddle1
bmpPaddle1.Top = YStartPaddle1
bmpPaddle1.Width = picPaddle.ScaleWidth
bmpPaddle1.Height = picPaddle.ScaleHeight
bmpPaddle2.Left = XPaddle2
bmpPaddle2.Top = YStartPaddle2
bmpPaddle2.Width = picPaddle.ScaleWidth
bmpPaddle2.Height = picPaddle.ScaleHeight
'Get ready to play
Paused = False
frmPong.Show
Call ResetPaddles
End Sub

picField KeyDown Event:

Private Sub picField_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
'Player 1 Motion
Case vbKeyA
If (bmpPaddle1.Top - PaddleIncrement) > 0 Then
Call Bitmap_Move(bmpPaddle1, bmpPaddle1.Left, bmpPaddle1.Top - PaddleIncrement, picPaddle)
End If
Case vbKeyZ
If (bmpPaddle1.Top + bmpPaddle1.Height + PaddleIncrement) < picField.ScaleHeight Then
Call Bitmap_Move(bmpPaddle1, bmpPaddle1.Left, bmpPaddle1.Top + PaddleIncrement, picPaddle)
End If
'Player 2 Motion
Case vbKeyK
If (bmpPaddle2.Top - PaddleIncrement) > 0 Then
Call Bitmap_Move(bmpPaddle2, bmpPaddle2.Left, bmpPaddle2.Top - PaddleIncrement, picPaddle)
End If
Case vbKeyM
If (bmpPaddle2.Top + bmpPaddle2.Height + PaddleIncrement) < picField.ScaleHeight Then
Call Bitmap_Move(bmpPaddle2, bmpPaddle2.Left, bmpPaddle2.Top + PaddleIncrement, picPaddle)
End If
End Select
End Sub

timGame Timer Event:

Private Sub timGame_Timer()
'Main routine
Dim XInc As Integer, YInc As Integer
Dim Collision1 As Integer, Collision2 As Integer, Collision As Integer
Static Previous As Integer
'If paused, do nothing
If Paused Then Exit Sub
'Determine ball motion increments
XInc = XDir * XSpeed
YInc = YDir * YSpeed
'Ball hits top wall
If (bmpBall.Top + YInc) < 0 Then
YDir = -YDir
YInc = YDir * YSpeed
Call NoisePlay(wavWall, SND_ASYNC)
End If
'Ball hits bottom wall
If (bmpBall.Top + bmpBall.Height + YInc) > picField.ScaleHeight Then
YDir = -YDir
YInc = YDir * YSpeed
Call NoisePlay(wavWall, SND_ASYNC)
End If
'Ball goes past left wall - Player 2 scores
If (bmpBall.Left) > picField.ScaleWidth Then
Call Update_Score(2)
End If
'Ball goes past right wall - Player 1 scores
If (bmpBall.Left + bmpBall.Width) < 0 Then
Call Update_Score(1)
End If
'Check if either paddle and ball collided
Collision1 = Collided(bmpBall, bmpPaddle1)
Collision2 = Collided(bmpBall, bmpPaddle2)
'Move ball
Call Bitmap_Move(bmpBall, bmpBall.Left + XInc, bmpBall.Top + YInc, picBall)
'If paddle hit, redraw paddle
If Collision1 Then
Call Bitmap_Move(bmpPaddle1, bmpPaddle1.Left, bmpPaddle1.Top, picPaddle)
Collision = Collision1
ElseIf Collision2 Then
Call Bitmap_Move(bmpPaddle2, bmpPaddle2.Left, bmpPaddle2.Top, picPaddle)
Collision = Collision2
End If
'If we hit a paddle, change ball direction
If Collision And (Not Previous) Then
NumBounce = NumBounce + 1
If NumBounce = BOUNCE Then
NumBounce = 0
XSpeed = XSpeed + SpeedUnit
YSpeed = YSpeed + SpeedUnit
End If
XDir = -XDir
Call NoisePlay(wavPaddleHit, SND_ASYNC)
End If
Previous = Collision
End Sub